home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 5 / Apprentice-Release5.iso / Source Code / C / Applications / Moscow ML 1.31 / source code / mosml / src / mosmllib / Binaryset.sml < prev    next >
Encoding:
Text File  |  1996-07-03  |  12.5 KB  |  386 lines  |  [TEXT/R*ch]
  1. (* Binaryset -- modified for Moscow ML 
  2.  * from SML/NJ library v. 0.2 
  3.  *
  4.  * COPYRIGHT (c) 1993 by AT&T Bell Laboratories.  
  5.  * See file mosml/copyrght/copyrght.att for details.
  6.  *
  7.  * This code was adapted from Stephen Adams' binary tree implementation
  8.  * of applicative integer sets.
  9.  *
  10.  *    Copyright 1992 Stephen Adams.
  11.  *
  12.  *    This software may be used freely provided that:
  13.  *      1. This copyright notice is attached to any copy, derived work,
  14.  *         or work including all or part of this software.
  15.  *      2. Any derived work must contain a prominent notice stating that
  16.  *         it has been altered from the original.
  17.  *
  18.  *   Name(s): Stephen Adams.
  19.  *   Department, Institution: Electronics & Computer Science,
  20.  *      University of Southampton
  21.  *   Address:  Electronics & Computer Science
  22.  *             University of Southampton
  23.  *         Southampton  SO9 5NH
  24.  *         Great Britian
  25.  *   E-mail:   sra@ecs.soton.ac.uk
  26.  *
  27.  *   Comments:
  28.  *
  29.  *     1.  The implementation is based on Binary search trees of Bounded
  30.  *         Balance, similar to Nievergelt & Reingold, SIAM J. Computing
  31.  *         2(1), March 1973.  The main advantage of these trees is that
  32.  *         they keep the size of the tree in the node, giving a constant
  33.  *         time size operation.
  34.  *
  35.  *     2.  The bounded balance criterion is simpler than N&R's alpha.
  36.  *         Simply, one subtree must not have more than `weight' times as
  37.  *         many elements as the opposite subtree.  Rebalancing is
  38.  *         guaranteed to reinstate the criterion for weight>2.23, but
  39.  *         the occasional incorrect behaviour for weight=2 is not
  40.  *         detrimental to performance.
  41.  *
  42.  *     3.  There are two implementations of union.  The default,
  43.  *         hedge_union, is much more complex and usually 20% faster.  I
  44.  *         am not sure that the performance increase warrants the
  45.  *         complexity (and time it took to write), but I am leaving it
  46.  *         in for the competition.  It is derived from the original
  47.  *         union by replacing the split_lt(gt) operations with a lazy
  48.  *         version. The `obvious' version is called old_union.
  49.  *
  50.  *     4.  Most time is spent in T', the rebalancing constructor.  If my
  51.  *         understanding of the output of *<file> in the sml batch
  52.  *         compiler is correct then the code produced by NJSML 0.75
  53.  *         (sparc) for the final case is very disappointing.  Most
  54.  *         invocations fall through to this case and most of these cases
  55.  *         fall to the else part, i.e. the plain contructor,
  56.  *         T(v,ln+rn+1,l,r).  The poor code allocates a 16 word vector
  57.  *         and saves lots of registers into it.  In the common case it
  58.  *         then retrieves a few of the registers and allocates the 5
  59.  *         word T node.  The values that it retrieves were live in
  60.  *         registers before the massive save.
  61.  *
  62.  *   Modified to functor to support general ordered values
  63.  *)
  64.  
  65. datatype 'item set = SET of ('item * 'item -> ordering) * 'item tree
  66. and 'item tree = 
  67.     E 
  68.   | T of {elt   : 'item, 
  69.       cnt   : int, 
  70.       left  : 'item tree,
  71.       right : 'item tree}
  72.  
  73. fun treeSize E = 0
  74.   | treeSize (T{cnt,...}) = cnt
  75.  
  76. fun numItems (SET(_, t)) = treeSize t
  77.     
  78. fun isEmpty (SET(_, E)) = true
  79.   | isEmpty _           = false
  80.  
  81. fun mkT(v,n,l,r) = T{elt=v,cnt=n,left=l,right=r}
  82.  
  83. (* N(v,l,r) = T(v,1+treeSize(l)+treeSize(r),l,r) *)
  84. fun N(v,E,E) = mkT(v,1,E,E)
  85.   | N(v,E,r as T{cnt=n,...}) = mkT(v,n+1,E,r)
  86.   | N(v,l as T{cnt=n,...}, E) = mkT(v,n+1,l,E)
  87.   | N(v,l as T{cnt=n,...}, r as T{cnt=m,...}) = mkT(v,n+m+1,l,r)
  88.  
  89. fun single_L (a,x,T{elt=b,left=y,right=z,...}) = N(b,N(a,x,y),z)
  90.   | single_L _ = raise Match
  91. fun single_R (b,T{elt=a,left=x,right=y,...},z) = N(a,x,N(b,y,z))
  92.   | single_R _ = raise Match
  93. fun double_L (a,w,T{elt=c,left=T{elt=b,left=x,right=y,...},right=z,...}) =
  94.       N(b,N(a,w,x),N(c,y,z))
  95.   | double_L _ = raise Match
  96. fun double_R (c,T{elt=a,left=w,right=T{elt=b,left=x,right=y,...},...},z) =
  97.       N(b,N(a,w,x),N(c,y,z))
  98.   | double_R _ = raise Match
  99.  
  100. (*
  101. **  val weight = 3
  102. **  fun wt i = weight * i
  103. *)
  104. fun wt (i : int) = i + i + i
  105.  
  106. fun T' (v,E,E) = mkT(v,1,E,E)
  107.   | T' (v,E,r as T{left=E,right=E,...}) = mkT(v,2,E,r)
  108.   | T' (v,l as T{left=E,right=E,...},E) = mkT(v,2,l,E)
  109.  
  110.   | T' (p as (_,E,T{left=T _,right=E,...})) = double_L p
  111.   | T' (p as (_,T{left=E,right=T _,...},E)) = double_R p
  112.  
  113.     (* these cases almost never happen with small weight*)
  114.   | T' (p as (_,E,T{left=T{cnt=ln,...},right=T{cnt=rn,...},...})) =
  115.         if ln<rn then single_L p else double_L p
  116.   | T' (p as (_,T{left=T{cnt=ln,...},right=T{cnt=rn,...},...},E)) =
  117.         if ln>rn then single_R p else double_R p
  118.  
  119.   | T' (p as (_,E,T{left=E,...})) = single_L p
  120.   | T' (p as (_,T{right=E,...},E)) = single_R p
  121.  
  122.   | T' (p as (v,l as T{elt=lv,cnt=ln,left=ll,right=lr},
  123.           r as T{elt=rv,cnt=rn,left=rl,right=rr})) =
  124.       if rn >= wt ln (*right is too big*)
  125.         then
  126.           let val rln = treeSize rl
  127.               val rrn = treeSize rr
  128.           in
  129.             if rln < rrn then single_L p else double_L p
  130.           end
  131.       else if ln >= wt rn (*left is too big*)
  132.         then
  133.           let val lln = treeSize ll
  134.               val lrn = treeSize lr
  135.           in
  136.             if lrn < lln then single_R p else double_R p
  137.           end
  138.       else mkT(v,ln+rn+1,l,r)
  139.  
  140. fun addt cmpKey t x = 
  141.     let fun h E = mkT(x,1,E,E)
  142.       | h (T{elt=v,left=l,right=r,cnt}) =
  143.         case cmpKey(x,v) of
  144.         LESS    => T'(v, h l, r)
  145.           | GREATER => T'(v, l, h r)
  146.           | EQUAL   => mkT(x,cnt,l,r)
  147.     in h t end
  148.  
  149. fun concat3 cmpKey E v r = addt cmpKey r v
  150.   | concat3 cmpKey l v E = addt cmpKey l v
  151.   | concat3 cmpKey (l as T{elt=v1,cnt=n1,left=l1,right=r1}) 
  152.                    v 
  153.            (r as T{elt=v2,cnt=n2,left=l2,right=r2}) =
  154.     if wt n1 < n2 then T'(v2, concat3 cmpKey l v l2, r2)
  155.     else if wt n2 < n1 then T'(v1, l1, concat3 cmpKey r1 v r)
  156.     else N(v,l,r)
  157.  
  158. fun split_lt cmpKey E x = E
  159.   | split_lt cmpKey (T{elt=v,left=l,right=r,...}) x =
  160.       case cmpKey(v,x) of
  161.         GREATER => split_lt cmpKey l x
  162.       | LESS    => concat3 cmpKey l v (split_lt cmpKey r x)
  163.       | _ => l
  164.  
  165. fun split_gt cmpKey E x = E
  166.   | split_gt cmpKey (T{elt=v,left=l,right=r,...}) x =
  167.       case cmpKey(v,x) of
  168.         LESS    => split_gt cmpKey r x
  169.       | GREATER => concat3 cmpKey (split_gt cmpKey l x) v r
  170.       | _       => r
  171.  
  172. fun min (T{elt=v,left=E,...}) = v
  173.   | min (T{left=l,...}) = min l
  174.   | min _ = raise Match
  175.     
  176. fun delmin (T{left=E,right=r,...}) = r
  177.   | delmin (T{elt=v,left=l,right=r,...}) = T'(v,delmin l,r)
  178.   | delmin _ = raise Match
  179.  
  180. fun delete' (E,r) = r
  181.   | delete' (l,E) = l
  182.   | delete' (l,r) = T'(min r,l,delmin r)
  183.  
  184. fun concat E s = s
  185.   | concat s E = s
  186.   | concat (t1 as T{elt=v1,cnt=n1,left=l1,right=r1})
  187.            (t2 as T{elt=v2,cnt=n2,left=l2,right=r2}) =
  188.        if wt n1 < n2 then T'(v2, concat t1 l2, r2)
  189.        else if wt n2 < n1 then T'(v1, l1, concat r1 t2)
  190.          else T'(min t2,t1, delmin t2)
  191.  
  192. fun hedge_union cmpKey s E = s
  193.   | hedge_union cmpKey E s = s
  194.   | hedge_union cmpKey (T{elt=v,left=l1,right=r1,...}) 
  195.                        (s2 as T{elt=v2,left=l2,right=r2,...}) =
  196.     let fun trim lo hi E = E
  197.       | trim lo hi (s as T{elt=v,left=l,right=r,...}) =
  198.         if cmpKey(v,lo) = GREATER
  199.         then if cmpKey(v,hi) = LESS then s else trim lo hi l
  200.         else trim lo hi r
  201.         
  202.     fun uni_bd s E _ _ = s
  203.       | uni_bd E (T{elt=v,left=l,right=r,...}) lo hi = 
  204.         concat3 cmpKey (split_gt cmpKey l lo) v (split_lt cmpKey r hi)
  205.       | uni_bd (T{elt=v,left=l1,right=r1,...})
  206.            (s2 as T{elt=v2,left=l2,right=r2,...}) lo hi =
  207.         concat3 cmpKey (uni_bd l1 (trim lo v s2) lo v)
  208.                        v (uni_bd r1 (trim v hi s2) v hi)
  209.           (* inv:  lo < v < hi *)
  210.  
  211.     (* all the other versions of uni and trim are
  212.      * specializations of the above two functions with
  213.      *     lo=-infinity and/or hi=+infinity 
  214.      *)
  215.  
  216.     fun trim_lo _ E = E
  217.       | trim_lo lo (s as T{elt=v,right=r,...}) =
  218.         case cmpKey(v,lo) of
  219.         GREATER => s
  220.           | _       => trim_lo lo r
  221.  
  222.     fun trim_hi _ E = E
  223.       | trim_hi hi (s as T{elt=v,left=l,...}) =
  224.         case cmpKey(v,hi) of
  225.         LESS => s
  226.           | _    => trim_hi hi l
  227.             
  228.     fun uni_hi s E _ = s
  229.       | uni_hi E (T{elt=v,left=l,right=r,...}) hi = 
  230.         concat3 cmpKey l v (split_lt cmpKey r hi)
  231.       | uni_hi (T{elt=v,left=l1,right=r1,...}) 
  232.            (s2 as T{elt=v2,left=l2,right=r2,...}) hi =
  233.         concat3 cmpKey (uni_hi l1 (trim_hi v s2) v) 
  234.                        v (uni_bd r1 (trim v hi s2) v hi)
  235.  
  236.     fun uni_lo s E _ = s
  237.       | uni_lo E (T{elt=v,left=l,right=r,...}) lo = 
  238.         concat3 cmpKey (split_gt cmpKey l lo) v r
  239.       | uni_lo (T{elt=v,left=l1,right=r1,...})
  240.            (s2 as T{elt=v2,left=l2,right=r2,...}) lo =
  241.         concat3 cmpKey (uni_bd l1 (trim lo v s2) lo v)
  242.                        v (uni_lo r1 (trim_lo v s2) v)
  243.     in 
  244.     concat3 cmpKey (uni_hi l1 (trim_hi v s2) v) 
  245.                      v (uni_lo r1 (trim_lo v s2) v)
  246.     end
  247.  
  248.   (* The old_union version is about 20% slower than
  249.    *  hedge_union in most cases 
  250.    *)
  251. fun old_union _ E s2 = s2
  252.   | old_union _ s1 E = s1
  253.   | old_union cmpKey (T{elt=v,left=l,right=r,...}) s2 = 
  254.       let val l2 = split_lt cmpKey s2 v
  255.           val r2 = split_gt cmpKey s2 v
  256.       in
  257.       concat3 cmpKey (old_union cmpKey l l2) v (old_union cmpKey r r2)
  258.       end
  259.  
  260. exception NotFound
  261.  
  262. fun empty cmpKey = SET(cmpKey, E)
  263.  
  264. fun singleton cmpKey x = SET(cmpKey, T{elt=x,cnt=1,left=E,right=E})
  265.  
  266. fun addList (SET(cmpKey, t), l) = 
  267.     SET(cmpKey, List.foldl (fn (i,s) => addt cmpKey s i) t l)
  268.  
  269. fun add (SET(cmpKey, t), x) = SET(cmpKey, addt cmpKey t x)
  270.  
  271. fun peekt cmpKey t x = 
  272.     let fun pk E = NONE
  273.       | pk (T{elt=v,left=l,right=r,...}) =
  274.         case cmpKey(x,v) of
  275.         LESS    => pk l
  276.           | GREATER => pk r
  277.           | _       => SOME v
  278.     in pk t end;
  279.  
  280. fun membert cmpKey t x = 
  281.     case peekt cmpKey t x of NONE => false | _ => true
  282.  
  283. fun peek (SET(cmpKey, t), x) = peekt cmpKey t x;
  284. fun member arg = case peek arg of NONE => false | _ => true
  285.  
  286. local
  287.     (* true if every item in t is in t' *)
  288.   fun treeIn cmpKey (t,t') = 
  289.       let fun isIn E = true
  290.         | isIn (T{elt,left=E,right=E,...}) = 
  291.           membert cmpKey t' elt
  292.         | isIn (T{elt,left,right=E,...}) = 
  293.               membert cmpKey t' elt andalso isIn left
  294.         | isIn (T{elt,left=E,right,...}) = 
  295.               membert cmpKey t' elt  andalso isIn right
  296.         | isIn (T{elt,left,right,...}) = 
  297.               membert cmpKey t' elt andalso isIn left andalso isIn right
  298.       in isIn t end
  299. in
  300. fun isSubset (SET(_, E),_) = true
  301.   | isSubset (_,SET(_, E)) = false
  302.   | isSubset (SET(cmpKey, t as T{cnt=n,...}),
  303.           SET(_,      t' as T{cnt=n',...})) =
  304.     (n<=n') andalso treeIn cmpKey (t,t')
  305.  
  306. fun equal (SET(_,E), SET(_, E)) = true
  307.   | equal (SET(cmpKey, t as T{cnt=n,...}),
  308.        SET(_,      t' as T{cnt=n',...})) =
  309.     (n=n') andalso treeIn cmpKey (t,t')
  310.   | equal _ = false
  311. end
  312.  
  313. fun retrieve arg = 
  314.     case peek arg of NONE => raise NotFound | SOME v => v
  315.  
  316. fun delete (SET(cmpKey, t), x) =
  317.     let fun delt E = raise NotFound
  318.       | delt (t as T{elt=v,left=l,right=r,...}) =
  319.         case cmpKey(x,v) of
  320.         LESS    => T'(v, delt l, r)
  321.           | GREATER => T'(v, l, delt r)
  322.           | _       => delete'(l,r)
  323.     in SET(cmpKey, delt t) end;
  324.  
  325. fun union (SET(cmpKey, t1), SET(_, t2)) = 
  326.     SET(cmpKey, hedge_union cmpKey t1 t2)
  327.  
  328. fun intersection (SET(cmpKey, t1), SET(_, t2)) = 
  329.     let fun intert E _ = E
  330.       | intert _ E = E
  331.       | intert t (T{elt=v,left=l,right=r,...}) =
  332.         let val l2 = split_lt cmpKey t v
  333.         val r2 = split_gt cmpKey t v
  334.         in
  335.         case peekt cmpKey t v of
  336.             NONE => concat (intert l2 l) (intert r2 r)
  337.           | _    => concat3 cmpKey (intert l2 l) v (intert r2 r)
  338.         end
  339.     in SET(cmpKey, intert t1 t2) end
  340.  
  341. fun difference (SET(cmpKey, t1), SET(_, t2)) = 
  342.     let fun difft E s = E
  343.       | difft s E  = s
  344.       | difft s (T{elt=v,left=l,right=r,...}) =
  345.         let val l2 = split_lt cmpKey s v
  346.         val r2 = split_gt cmpKey s v
  347.         in
  348.         concat (difft l2 l) (difft r2 r)
  349.         end
  350.     in SET(cmpKey, difft t1 t2) end
  351.  
  352. fun foldr f b (SET(_, t)) =
  353.     let fun foldf E b = b
  354.       | foldf (T{elt,left,right,...}) b = 
  355.         foldf left (f(elt, foldf right b))
  356.     in foldf t b end
  357.  
  358. fun foldl f b (SET(_, t)) =
  359.     let fun foldf E b = b
  360.       | foldf (T{elt,left,right,...}) b = 
  361.         foldf right (f(elt, foldf left b))
  362.     in foldf t b end
  363.  
  364. fun listItems set = foldr (op::) [] set
  365.  
  366. fun revapp f (SET(_, t)) =
  367.     let fun apply E = ()
  368.       | apply (T{elt,left,right,...}) = 
  369.         (apply right; f elt; apply left)
  370.     in apply t end
  371.  
  372. fun app f (SET(_, t)) =
  373.     let fun apply E = ()
  374.       | apply (T{elt,left,right,...}) = 
  375.         (apply left; f elt; apply right)
  376.     in apply t end
  377.  
  378. fun find p (SET(_, t)) = 
  379.     let fun findt E = NONE
  380.       | findt (T{elt,left,right,...}) =
  381.         if p elt then SOME elt
  382.         else case findt left of
  383.         NONE => findt right
  384.           | a    => a 
  385.     in findt t end
  386.